unit uSBDUnit_TestHarness;
interface
uses uSBDUnit_TestNode_InternalSupport, uSBD_BaseTypes, uSBDUnit_Model,
     uSBD_ServiceProvider, uSBDUnit_TestScheduler, Classes, Generics.Defaults;


type

TBufferedTestHarness = class( TSBD_RefCountedCommonBase, ITestHarness, ITestHarnessEx)
  private
    FHasFailed: boolean;
    FFailMessage: string;
    FFailStamp: TDateTime;
    FNonFailMessages: TNonFailMessageArray;
    FTestSuiteClass: TClass;

    procedure Fail( const FailMessage: string );  // raise exception.
    function  HasFailed: boolean;
    function  FailMessage: string;
    function  FailStamp: TDateTime;
    function  NonFailMessages: TNonFailMessageArray;
    procedure SetTestSuiteClass( Class1: TClass);

  protected
    function  MonitoringSuppression: IInterface; virtual;

    procedure Check  ( Condition: boolean; const Msg: string = '');                   virtual;
    procedure Warning( Condition: boolean; const Msg: string = '');                   virtual;
    procedure Info   ( const InfoMessage: string);                                    virtual;
    procedure CheckFalse    ( Condition: Boolean; const Msg: string = '');            virtual;

    procedure CheckEquals   ( Expected, Actual: Extended; const Msg: string = ''); overload;                               virtual;
    procedure CheckEquals   ( Expected, Actual: Extended; Tolerance: Extended = 0.0; const Msg: string = ''); overload;    virtual;
    procedure CheckEquals   ( Expected, Actual: integer; const Msg: string = ''); overload;                                virtual;
    procedure CheckEquals   ( Expected, Actual: cardinal; const Msg: string = ''); overload;                               virtual;
    procedure CheckEquals   ( Expected, Actual: int64; const Msg: string = ''); overload;                                  virtual;
    procedure CheckEquals   ( Expected, Actual: uint64; const Msg: string = ''); overload;                                 virtual;
    procedure CheckEquals   ( const Expected, Actual: string; const Msg: string = ''); overload;                           virtual;
    procedure CheckEquals   ( const Expected, Actual: RawByteString; const Msg: string = ''); overload;                    virtual;
    procedure CheckEquals   ( const Expected, Actual: AnsiString; const Msg: string = ''); overload;                       virtual;
    procedure CheckEqualsMem( expected, actual: pointer; size:longword; const Msg:string='');                              virtual;
    procedure CheckEquals   ( Expected, Actual: boolean; const Msg: string = ''); overload;                                virtual;
    procedure CheckNull     ( const Intft: IInterface; const Msg: string = ''); overload;                                  virtual;
    procedure CheckNull     ( Obj: TObject; const Msg: string = ''); overload;                                             virtual;
    procedure CheckSame     ( const Expected, Actual: IInterface; const Msg: string = ''); overload;                       virtual;
    procedure CheckSameIntf ( const Expected, Actual: IInterface; const CastIID: TGUID; const Msg: string = ''); overload; virtual;
    procedure CheckSame     ( Expected, Actual: TObject; const Msg: string = ''); overload;                                virtual;
    procedure CheckEquals   ( Expected, Actual: TClass; const Msg: string = ''); overload;                                 virtual;
    procedure CheckInherits ( Expected, Actual: TClass; const Msg: string = ''); overload;                                 virtual;
    procedure CheckIs       ( Obj: TObject; Cls: TClass; const Msg: string = ''); overload;                                virtual;
    procedure CheckClassHasAttribute( Cls: TClass; Attrib: TCustomAttributeClass; const Msg: string = '');                 virtual;

    procedure CheckNotEquals   ( Expected, Actual: Extended; const Msg: string = ''); overload;                            virtual;
    procedure CheckNotEquals   ( Expected, Actual: Extended; Tolerance: Extended = 0.0; const Msg: string = ''); overload; virtual;
    procedure CheckNotEquals   ( Expected, Actual: integer; const Msg: string = ''); overload;                             virtual;
    procedure CheckNotEquals   ( Expected, Actual: cardinal; const Msg: string = ''); overload;                            virtual;
    procedure CheckNotEquals   ( Expected, Actual: int64; const Msg: string = ''); overload;                               virtual;
    procedure CheckNotEquals   ( Expected, Actual: uint64; const Msg: string = ''); overload;                              virtual;
    procedure CheckNotEquals   ( const Expected, Actual: string; const Msg: string = ''); overload;                        virtual;
    procedure CheckNotEquals   ( const Expected, Actual: RawByteString; const Msg: string = ''); overload;                 virtual;
    procedure CheckNotEquals   ( const Expected, Actual: AnsiString; const Msg: string = ''); overload;                    virtual;
    procedure CheckNotEqualsMem( expected, actual: pointer; size:longword; const Msg:string='');                           virtual;
    procedure CheckNotEquals   ( Expected, Actual: boolean; const Msg: string = ''); overload;                             virtual;
    procedure CheckNotNull     ( const Intft: IInterface; const Msg: string = ''); overload;                               virtual;
    procedure CheckNotNull     ( Obj: TObject; const Msg: string = ''); overload;                                          virtual;
    procedure CheckNotSame     ( const Expected, Actual: IInterface; const Msg: string = ''); overload;                         virtual;
    procedure CheckNotSameIntf ( const Expected, Actual: IInterface; const CastIID: TGUID; const Msg: string = ''); overload;   virtual;
    procedure CheckNotSame     ( Expected, Actual: TObject; const Msg: string = ''); overload;                                  virtual;
    procedure CheckNotEquals   ( Expected, Actual: TClass; const Msg: string = ''); overload;                              virtual;
    procedure CheckNotInherits ( Expected, Actual: TClass; const Msg: string = ''); overload;                              virtual;
    procedure CheckNotIs       ( Obj: TObject; Cls: TClass; const Msg: string = ''); overload;                             virtual;
    procedure CheckXMLisWellFormed( const sXML: utf8string; const Msg: string);        virtual;

    procedure Clear; virtual;
    procedure ShutDown; virtual;
    procedure MarkFail( const FailMessage: string; WhenFail: TDateTime = 0.0);    virtual;
    procedure AddNonFailMessage( const Addend: INonFailMessage);  virtual;
    class function  ExceptionClass: TSBDUnit_ExceptionClass;                      override;

  public
    [Configuration('Buffered')] constructor ServiceModeCreate( const Config: string);  virtual;
  end;

[BlacklistConfigs('Buffered')]
TMasteredTestHarness = class( TBufferedTestHarness, ITestHarnessEx, ITestHarnessExWithTestModulation)
  private
    [Injection] FMaster: INodeMaster;
    [Injection] FLeakages: ILeakageDetector;
    FTestNode: ITestNode;
    FTestPoint: ITestPoint;

    procedure BeginLeakageSensing( doMonitor1: boolean);
    function  EndLeakageSensing: boolean;

  protected
    function  MonitoringSuppression: IInterface;                                      override;
    procedure Check  ( Condition: boolean; const Msg: string = '');                   override;
    procedure Warning( Condition: boolean; const Msg: string = '');                   override;
    procedure Info   ( const InfoMessage: string);                                    override;

    procedure ShutDown; override;
    procedure MarkFail( const FailMessage: string; WhenFail: TDateTime = 0.0);     override;
    procedure AddNonFailMessage( const Addend: INonFailMessage);  override;
    procedure SetParentNodeAsIntf( const Value: IInterface);      override;

  public
    [Configuration('Mastered')] constructor ServiceModeCreate( const Config: string); override;
  end;


TTestSuiteAccess = class( TTestSuite) end;

TGenericCheckable<T> = class( TInterfacedObject, IEqualityComparer<T>)
  protected
    function Equals( const Left, Right: T): Boolean;                                   virtual;
    function GetHashCode( const Value: T): Integer;                                    virtual;
    class function TypeDisplayName: string;                                           virtual;
    function EqualityComparer: IEqualityComparer<T>;                                  virtual;
    class function AsDisplayString( const Value: T): string;                          virtual; abstract;
    function DefaultEqualsErrorMessageFmt   : string;  virtual; // %0:s is replaced by Expected; %1:s is replaced by Actual; %2:s is replaced by TypeDisplayName;
    function DefaultNotEqualsErrorMessageFmt: string;  virtual; // %0:s is replaced by Expected/Actual (being equal); %1:s is replaced by TypeDisplayName

  public
    procedure CheckEquals   ( const Harness: ITestHarness; const Expected, Actual: T; const Msg: string);   overload;
    procedure CheckNotEquals( const Harness: ITestHarness; const Expected, Actual: T; const Msg: string);   overload;
    procedure CheckEquals   (       Harness: TTestSuite  ; const Expected, Actual: T; const Msg: string);   overload;
    procedure CheckNotEquals(       Harness: TTestSuite  ; const Expected, Actual: T; const Msg: string);   overload;
    function  Hold( out SelfObj{: TGenericCheckable<T>}): IInterface;
  end;


TSBDUnit_HarnessException = class( TSBDUnit_Exception) end;

procedure RegisterServices( const Registrar: IServiceProvider);


implementation






uses SysUtils, uSBDUnit_Types, Rtti, XMLIntf, XMLDoc;

type
TStackBasedCheckable<T> = class( TGenericCheckable<T>)
  end;

THeapBasedCheckable<T> = class( TGenericCheckable<T>)
  protected
    function EqualityComparer: IEqualityComparer<T>;  override;
  end;


TCheckableString = class( THeapBasedCheckable<string>)
  protected
    function Equals( const Left, Right: string): Boolean;                                  override;
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: string): string;                          override;
  end;

TCheckableCaseInsensitiveString = class( TCheckableString)
  protected
    function Equals( const Left, Right: string): Boolean;                                  override;
  end;

TCheckableRawByteString = class( TGenericCheckable<rawbytestring>)
  protected
    function Equals( const Left, Right: rawbytestring): Boolean;                                  override;
    class function TypeDisplayName: string;                                                override;
    function EqualityComparer: IEqualityComparer<rawbytestring>;                            override;
    class function AsDisplayString( const Value: rawbytestring): string;                          override;
  end;

TCheckableAnsiString = class( TGenericCheckable<ansistring>)
  protected
    function Equals( const Left, Right: ansistring): Boolean;                                  override;
    class function TypeDisplayName: string;                                                override;
    function EqualityComparer: IEqualityComparer<ansistring>;                            override;
    class function AsDisplayString( const Value: ansistring): string;                          override;
  end;


TCheckableCaseInsensitiveAnsiString = class( TCheckableAnsiString)
  protected
    function Equals( const Left, Right: ansistring): Boolean;                                  override;
  end;


TCheckableInteger = class( TStackBasedCheckable<integer>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: integer): string;                          override;
  end;

TCheckableCardinal = class( TStackBasedCheckable<cardinal>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: cardinal): string;                          override;
  end;

TCheckableInt64 = class( TStackBasedCheckable<int64>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: int64): string;                          override;
  end;

TCheckableUInt64 = class( TStackBasedCheckable<uint64>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: uint64): string;                          override;
  end;

TCheckableExtended = class( TStackBasedCheckable<extended>)
  protected
    FTolerance: Extended;
    function Equals( const Left, Right: Extended): Boolean;                                   override;
    class function TypeDisplayName: string;                                                override;
    function EqualityComparer: IEqualityComparer<extended>;                            override;
    class function AsDisplayString( const Value: extended): string;                          override;
  public
    constructor Create( Tolerance1: Extended);
  end;


TCheckablePointer = class( TStackBasedCheckable<pointer>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: pointer): string;                          override;
  end;

TCheckableBoolean = class( TStackBasedCheckable<boolean>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: boolean): string;                          override;
  end;

TCheckableLongword = class( TStackBasedCheckable<longword>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: longword): string;                          override;
  end;

TCheckableObject = class( TStackBasedCheckable<TObject>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: TObject): string;                          override;
  end;

TCheckableClass = class( TStackBasedCheckable<TClass>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: TClass): string;                          override;
  end;

TCheckableInterface = class( TStackBasedCheckable<IInterface>)
  protected
    class function TypeDisplayName: string;                                                override;
    class function AsDisplayString( const Value: IInterface): string;                          override;
  end;

TCheckableCastInterface = class( TCheckableInterface)
  protected
    FCastIID: TGUID;
    class function TypeDisplayName: string;                                                override;
    function Equals( const Left, Right: IInterface): Boolean;                                   override;
    function EqualityComparer: IEqualityComparer<IInterface>;                            override;
  public
    constructor Create( const CastIID: TGUID);
  end;

procedure RegisterServices( const Registrar: IServiceProvider);
begin
Registrar.RegisterServiceClass( TBufferedTestHarness, ITestHarness).Free; //  'Buffered'
Registrar.RegisterServiceClass( TMasteredTestHarness, ITestHarness).Free; //  'Mastered'
end;



{ TBufferedTestHarness }

constructor TBufferedTestHarness.ServiceModeCreate( const Config: string);
begin
FHasFailed   := False;
FFailMessage := '';
FFailStamp   := 0.0;
SetLength( FNonFailMessages, 0);
end;

procedure TBufferedTestHarness.SetTestSuiteClass( Class1: TClass);
begin
FTestSuiteClass := Class1
end;

procedure TBufferedTestHarness.ShutDown;
begin
SetLength( FNonFailMessages, 0)
end;

procedure TBufferedTestHarness.AddNonFailMessage( const Addend: INonFailMessage);
var
  L: integer;
begin
MonitoringSuppression;
L := Length( FNonFailMessages);
SetLength( FNonFailMessages, L+1);
FNonFailMessages[L] := Addend;
end;

procedure TBufferedTestHarness.Check(
  Condition: boolean; const Msg: string = '');
begin
if not Condition then
  Fail( FailMessage)
end;

procedure TBufferedTestHarness.CheckClassHasAttribute(
  Cls: TClass; Attrib: TCustomAttributeClass; const Msg: string);
var
  Rtti: TRttiContext;
  A: TCustomAttribute;
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := False;
if assigned( Cls) and assigned( Attrib) then
  begin
  Rtti := TRttiContext.Create;
  for A in Rtti.GetType( Cls).GetAttributes do
    begin
    Ok := A.InheritsFrom( Attrib);
    if Ok then break
    end;
  Rtti.Free
  end;
if Ok then exit;
if Msg <> '' then
    Msg2 := Msg
  else if not assigned( Cls) then
    Msg2 := 'Expected nil class to have attribute.'
  else if not assigned( Attrib) then
    Msg2 := Format( 'Expected class %s to have nil attribute.', [Cls.ClassName])
  else
    Msg2 := Format('Expected class %s to have attribute %s, but it did not.',
                   [Cls.ClassName, Attrib.ClassName]);
Fail( Msg2)
end;


procedure TBufferedTestHarness.CheckEquals( const Expected, Actual, Msg: string);
var
  Checker: TCheckableString;
begin
MonitoringSuppression;
TCheckableString.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;


procedure TBufferedTestHarness.CheckEquals(
  const Expected, Actual: RawByteString; const Msg: string);
var
  Checker: TCheckableRawByteString;
begin
MonitoringSuppression;
TCheckableRawByteString.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  const Expected, Actual: AnsiString; const Msg: string);
var
  Checker: TCheckableAnsiString;
begin
MonitoringSuppression;
TCheckableAnsiString.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals( Expected, Actual: uint64;
  const Msg: string);
var
  Checker: TCheckableUInt64;
begin
MonitoringSuppression;
TCheckableUInt64.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual, Tolerance: Extended; const Msg: string);
var
  Checker: TCheckableExtended;
begin
MonitoringSuppression;
TCheckableExtended.Create( Tolerance).Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: Extended; const Msg: string);
begin
MonitoringSuppression;
CheckEquals( Expected, Actual, 0.0, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: integer; const Msg: string);
var
  Checker: TCheckableInteger;
begin
MonitoringSuppression;
TCheckableInteger.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: int64; const Msg: string);
var
  Checker: TCheckableInt64;
begin
MonitoringSuppression;
TCheckableInt64.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: cardinal; const Msg: string);
var
  Checker: TCheckableCardinal;
begin
MonitoringSuppression;
TCheckableCardinal.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: boolean; const Msg: string);
var
  Checker: TCheckableBoolean;
begin
MonitoringSuppression;
TCheckableBoolean.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEquals(
  Expected, Actual: TClass; const Msg: string);
var
  Checker: TCheckableClass;
begin
MonitoringSuppression;
TCheckableClass.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckEqualsMem(
  Expected, Actual: pointer;
  Size: longword; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := (Size = 0) or (assigned( Expected) and assigned( Actual) and
                     CompareMem( Expected, Actual, Size));
if Ok then exit;
if Msg = '' then
    Msg2 := Format( 'Memory blobs of size %d not equal.', [Size])
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckFalse(
  Condition: Boolean; const Msg: string);
begin
MonitoringSuppression;
Check( not Condition, Msg)
end;

procedure TBufferedTestHarness.CheckInherits(
  Expected, Actual: TClass; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Actual) and assigned( Expected) and Actual.InheritsFrom( Expected);
if Ok then exit;
if Msg = '' then
    begin
    if not assigned( Actual) then
        Msg2 := 'nil class expected to inherit.'
      else if not assigned( Expected) then
        Msg2 := Format( 'class %s expected to inherit from nil.', [Actual.ClassName])
      else
        Msg2 := Format( 'class %s does not inherit from %s as expected.', [Actual.ClassName, Expected.ClassName])
    end
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckIs(
  Obj: TObject; Cls: TClass; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Cls) and (Obj is Cls);
if Ok then exit;
if Msg = '' then
    begin
    if not assigned( Cls) then
        Msg2 := 'object expected to inherit from nil class.'
      else
        Msg2 := Format( 'object does not inherit from %s as expected.', [Cls.ClassName])
    end
  else
    Msg2 := Msg;
Fail( Msg2)
end;


procedure TBufferedTestHarness.CheckNotEquals(
  const Expected, Actual, Msg: string);
var
  Checker: TCheckableString;
begin
MonitoringSuppression;
TCheckableString.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  const Expected, Actual: RawByteString; const Msg: string);
var
  Checker: TCheckableRawByteString;
begin
MonitoringSuppression;
TCheckableRawByteString.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(const Expected,
  Actual: AnsiString; const Msg: string);
var
  Checker: TCheckableAnsiString;
begin
MonitoringSuppression;
TCheckableAnsiString.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;


procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: cardinal; const Msg: string);
var
  Checker: TCheckableCardinal;
begin
MonitoringSuppression;
TCheckableCardinal.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;


procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: int64; const Msg: string);
var
  Checker: TCheckableInt64;
begin
MonitoringSuppression;
TCheckableInt64.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: uint64; const Msg: string);
var
  Checker: TCheckableUInt64;
begin
MonitoringSuppression;
TCheckableUInt64.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual, Tolerance: Extended; const Msg: string);
var
  Checker: TCheckableExtended;
begin
MonitoringSuppression;
TCheckableExtended.Create( Tolerance).Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: Extended; const Msg: string);
begin
MonitoringSuppression;
CheckNotEquals( Expected, Actual, 0.0, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: integer; const Msg: string);
var
  Checker: TCheckableInteger;
begin
MonitoringSuppression;
TCheckableInteger.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: boolean; const Msg: string);
var
  Checker: TCheckableBoolean;
begin
MonitoringSuppression;
TCheckableBoolean.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotEquals(
  Expected, Actual: TClass; const Msg: string);
var
  Checker: TCheckableClass;
begin
MonitoringSuppression;
TCheckableClass.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;


procedure TBufferedTestHarness.CheckNotEqualsMem(
  Expected, Actual: pointer; Size: longword; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := not( (Size = 0) or (assigned( Expected) and assigned( Actual) and
                          CompareMem( Expected, Actual, Size)));
if Ok then exit;
if Msg = '' then
    Msg2 := Format( 'Memory blobs of size %d equal.', [Size])
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNotInherits(
  Expected, Actual: TClass; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Actual) and assigned( Expected) and (not Actual.InheritsFrom( Expected));
if Ok then exit;
if Msg = '' then
    begin
    if not assigned( Actual) then
        Msg2 := 'nil class expected to not inherit.'
      else if not assigned( Expected) then
        Msg2 := Format( 'class %s expected to not inherit from nil.', [Actual.ClassName])
      else
        Msg2 := Format( 'class %s inherits from %s contrary to expectation.', [Actual.ClassName, Expected.ClassName])
    end
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNotIs(
  Obj: TObject; Cls: TClass; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Cls) and (not (Obj is Cls));
if Ok then exit;
if Msg = '' then
    begin
    if not assigned( Cls) then
        Msg2 := 'object expected to not inherit from nil class.'
      else
        Msg2 := Format( 'object inherits from %s contrary to expectation.', [Cls.ClassName])
    end
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNotNull(
  const Intft: IInterface; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Intft);
if Ok then exit;
if Msg = '' then
    Msg2 := 'interface nil when expected assigned.'
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNotNull( Obj: TObject; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := assigned( Obj);
if Ok then exit;
if Msg = '' then
    Msg2 := 'object nil when expected assigned.'
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNotSame(
  Expected, Actual: TObject; const Msg: string);
var
  Checker: TCheckableObject;
begin
MonitoringSuppression;
TCheckableObject.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotSame(
  const Expected, Actual: IInterface; const Msg: string);
var
  Checker: TCheckableInterface;
begin
MonitoringSuppression;
TCheckableInterface.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNotSameIntf(const Expected,
  Actual: IInterface; const CastIID: TGUID; const Msg: string);
var
  Checker: TCheckableCastInterface;
begin
MonitoringSuppression;
TCheckableCastInterface.Create( CastIID).Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckNull(
  const Intft: IInterface; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := not assigned( Intft);
if Ok then exit;
if Msg = '' then
    Msg2 := 'interface assigned when expected nil.'
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckNull( Obj: TObject; const Msg: string);
var
  Ok: boolean;
  Msg2: string;
begin
MonitoringSuppression;
Ok := not assigned( Obj);
if Ok then exit;
if Msg = '' then
    Msg2 := 'object nil when expected assigned.'
  else
    Msg2 := Msg;
Fail( Msg2)
end;

procedure TBufferedTestHarness.CheckSame(
  Expected, Actual: TObject; const Msg: string);
var
  Checker: TCheckableObject;
begin
MonitoringSuppression;
TCheckableObject.Create.Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckSame(
  const Expected, Actual: IInterface; const Msg: string);
var
  Checker: TCheckableInterface;
begin
MonitoringSuppression;
TCheckableInterface.Create.Hold( Checker);
Checker.CheckNotEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckSameIntf(
  const Expected, Actual: IInterface; const CastIID: TGUID; const Msg: string);
var
  Checker: TCheckableCastInterface;
begin
MonitoringSuppression;
TCheckableCastInterface.Create( CastIID).Hold( Checker);
Checker.CheckEquals( self, Expected, Actual, Msg)
end;

procedure TBufferedTestHarness.CheckXMLisWellFormed( const sXML: UTF8String; const Msg: string);
const
  XML_ClipLen = 250;
var
  Ok: boolean;
  CompOwner: TComponent;
  Doc: TXMLDocument;
  Msg2: string;
begin
MonitoringSuppression;
Ok := sXML <> '';
if Ok then
  try
    CompOwner := TComponent.Create( nil);
    try
      Doc := TXMLDocument.Create( CompOwner);
      Doc.LoadFromXML( sXML);
      Doc.Active := True;
      Ok := True
    finally
      CompOwner.Free
    end
  except
    Ok := False
  end;
if Ok then exit;
if Msg <> '' then
    Msg2 := Msg
  else
    begin
    Msg2 := 'XML ''' + sXML;
    if Length( Msg2) >= XML_ClipLen then
      begin
      SetLength( Msg2, XML_ClipLen - 3);
      Msg2 := Msg2 + '...'
      end;
    Msg2 := Msg2 + ''' not well formed.'
    end;
Fail( Msg2)
end;

procedure TBufferedTestHarness.Clear;
begin
FHasFailed   := False;
FFailMessage := '';
FFailStamp   := 0.0;
SetLength( FNonFailMessages, 0)
end;

class function TBufferedTestHarness.ExceptionClass: TSBDUnit_ExceptionClass;
begin
result := TSBDUnit_HarnessException
end;

procedure TBufferedTestHarness.Fail(const FailMessage: string);
begin
MonitoringSuppression;
MarkFail( FailMessage);
raise UserFailException.Create( FTestSuiteClass, FailMessage);
// This exception will be caught and converted into procedure TTestCaseNode.AutoFail( reasonFailMethod, ...)
end;


function TBufferedTestHarness.FailMessage: string;
begin
result := FFailMessage
end;

function TBufferedTestHarness.FailStamp: TDateTime;
begin
result := FFailStamp
end;

function TBufferedTestHarness.HasFailed: boolean;
begin
result := FHasFailed
end;

procedure TBufferedTestHarness.Info( const InfoMessage: string);
var
  InfoAddend: INonFailMessage;
  Setter: INonFailMessageEx;
  L: integer;
begin
MonitoringSuppression;
AcquireService( INonFailMessage, InfoAddend, 'Info');
L := Length( FNonFailMessages);
SetLength( FNonFailMessages, L + 1);
FNonFailMessages[L] := InfoAddend;
if Supports( InfoAddend, INonFailMessageEx, Setter) then
  Setter.SetNonFailMessage( Now, InfoMessage);
end;

procedure TBufferedTestHarness.Warning( Condition: boolean; const Msg: string = '');
var
  WarnAddend: INonFailMessage;
  Setter: INonFailMessageEx;
  L: integer;
begin
MonitoringSuppression;
if not Condition then exit;
AcquireService( INonFailMessage, WarnAddend, 'Warning');
L := Length( FNonFailMessages);
SetLength( FNonFailMessages, L + 1);
FNonFailMessages[L] := WarnAddend;
if Supports( WarnAddend, INonFailMessageEx, Setter) then
  Setter.SetNonFailMessage( Now, Msg)
end;

procedure TBufferedTestHarness.MarkFail(
  const FailMessage: string; WhenFail: TDateTime);
begin
MonitoringSuppression;
FHasFailed := True;
if FFailMessage = '' then
  begin
  FFailMessage := FailMessage;
  if WhenFail = 0.0 then
    WhenFail := Now;
  FFailStamp   := WhenFail
  end
end;

function TBufferedTestHarness.MonitoringSuppression: IInterface;
begin
result := nil
end;

function TBufferedTestHarness.NonFailMessages: TNonFailMessageArray;
begin
result := FNonFailMessages
end;


{ TMasteredTestHarness }
constructor TMasteredTestHarness.ServiceModeCreate( const Config: string);
begin
inherited ServiceModeCreate( Config)
end;

procedure TMasteredTestHarness.SetParentNodeAsIntf( const Value: IInterface);
begin
Supports( Value, ITestNode , FTestNode);
Supports( Value, ITestPoint, FTestPoint)
end;

procedure TMasteredTestHarness.ShutDown;
begin
inherited;
FMaster    := nil;
FTestNode  := nil;
FTestPoint := nil
end;



procedure TMasteredTestHarness.AddNonFailMessage( const Addend: INonFailMessage);
begin
MonitoringSuppression;
inherited AddNonFailMessage( Addend);
if assigned( FMaster) then
  FMaster.NonFailMessageArrived( FTestNode, Length( FNonFailMessages)-1)
end;

procedure TMasteredTestHarness.Check( Condition: boolean; const Msg: string);
begin
if not Condition then
  Fail( Msg)
end;

procedure TMasteredTestHarness.BeginLeakageSensing( doMonitor1: boolean);
begin
if doMonitor1 then
  FLeakages.EnterMonitoring
end;

function TMasteredTestHarness.EndLeakageSensing: boolean;
var
  Leakage: int64;
begin
if FLeakages.IsMonitoring then
    result := not FLeakages.LeaveMonitoring( Leakage)
  else
    result := False
end;

procedure TMasteredTestHarness.Info(const InfoMessage: string);
begin
MonitoringSuppression;
inherited Info( InfoMessage);
if assigned( FMaster) then
  FMaster.NonFailMessageArrived( FTestNode, Length( FNonFailMessages)-1)
end;

procedure TMasteredTestHarness.Warning(
  Condition: boolean; const Msg: string = '');
begin
MonitoringSuppression;
inherited Warning( Condition, Msg);
if Condition and assigned( FMaster) then
  FMaster.NonFailMessageArrived( FTestNode, Length( FNonFailMessages)-1)
end;

procedure TMasteredTestHarness.MarkFail(
  const FailMessage: string; WhenFail: TDateTime);
begin
MonitoringSuppression;
inherited MarkFail( FailMessage, WhenFail);
if assigned( FTestPoint) then
  FTestPoint.ExecutionResult := erFail
end;


function TMasteredTestHarness.MonitoringSuppression: IInterface;
begin
if assigned( FLeakages) and FLeakages.IsMonitoring then
    result := FLeakages.MonitoringSuppression
  else
    result := nil
end;

{ THeapBasedCheckable<T> }

function THeapBasedCheckable<T>.EqualityComparer: IEqualityComparer<T>;
begin
result := self
end;

{ TCheckableString }

class function TCheckableString.AsDisplayString( const Value: string): string;
begin
result := '''' + Value + ''''
end;

function TCheckableString.Equals( const Left, Right: string): Boolean;
begin
result := Left = Right
end;

class function TCheckableString.TypeDisplayName: string;
begin
result := 'string'
end;

{ TCheckableCaseInsensitiveString }

function TCheckableCaseInsensitiveString.Equals(
  const Left, Right: string): Boolean;
begin
result := SameText( Left, Right)
end;

{ TCheckableRawByteString }

class function TCheckableRawByteString.AsDisplayString(
  const Value: rawbytestring): string;
begin
result := '''' + Value + ''''
end;

function TCheckableRawByteString.EqualityComparer: IEqualityComparer<rawbytestring>;
begin
result := self
end;

function TCheckableRawByteString.Equals(
  const Left, Right: rawbytestring): Boolean;
begin
result := Left = Right
end;

class function TCheckableRawByteString.TypeDisplayName: string;
begin
result := 'rawbytestring'
end;

{ TCheckableAnsiString }

class function TCheckableAnsiString.AsDisplayString(
  const Value: ansistring): string;
begin
result := '''' + Value + ''''
end;

function TCheckableAnsiString.EqualityComparer: IEqualityComparer<ansistring>;
begin
result := self
end;

function TCheckableAnsiString.Equals(const Left, Right: ansistring): Boolean;
begin
result := Left = Right
end;

class function TCheckableAnsiString.TypeDisplayName: string;
begin
result := 'ansistring'
end;

{ TCheckableCaseInsensitiveAnsiString }

function TCheckableCaseInsensitiveAnsiString.Equals(
  const Left, Right: ansistring): Boolean;
begin
result := AnsiStrIComp( PAnsiChar( Left), PAnsiChar( Right)) = 0
end;

{ TCheckableInteger }

class function TCheckableInteger.AsDisplayString(const Value: integer): string;
begin
result := Format( '%d', [Value])
end;

class function TCheckableInteger.TypeDisplayName: string;
begin
result := 'integer'
end;

{ TCheckableCardinal }

class function TCheckableCardinal.AsDisplayString(
  const Value: cardinal): string;
begin
result := Format( '%d', [Value])
end;

class function TCheckableCardinal.TypeDisplayName: string;
begin
result := 'cardinal'
end;

{ TCheckableExtended }

class function TCheckableExtended.AsDisplayString(
  const Value: extended): string;
begin
result := Format( '%f', [Value])
end;

constructor TCheckableExtended.Create(Tolerance1: Extended);
begin
FTolerance := Tolerance1
end;

function TCheckableExtended.EqualityComparer: IEqualityComparer<extended>;
begin
result := self
end;

function TCheckableExtended.Equals(const Left, Right: Extended): Boolean;
begin
result := Left = Right
end;

class function TCheckableExtended.TypeDisplayName: string;
begin
result := 'float'
end;

{ TCheckableInt64 }

class function TCheckableInt64.AsDisplayString(const Value: int64): string;
begin
result := Format( '%d', [Value])
end;

class function TCheckableInt64.TypeDisplayName: string;
begin
result := 'int64'
end;

{ TCheckableUInt64 }

class function TCheckableUInt64.AsDisplayString(const Value: uint64): string;
begin
result := Format( '%d', [Value])
end;

class function TCheckableUInt64.TypeDisplayName: string;
begin
result := 'uint64'
end;

{ TCheckablePointer }

class function TCheckablePointer.AsDisplayString( const Value: pointer): string;
begin
result := Format( '$%x', [NativeUInt(Value)])
end;

class function TCheckablePointer.TypeDisplayName: string;
begin
result := 'pointer'
end;

{ TCheckableBoolean }

class function TCheckableBoolean.AsDisplayString(const Value: boolean): string;
begin
if Value then
    result := 'True'
  else
    result := 'False'
end;

class function TCheckableBoolean.TypeDisplayName: string;
begin
result := 'boolean'
end;


{ TGenericCheckable<T> }


procedure TGenericCheckable<T>.CheckEquals(
  const Harness: ITestHarness; const Expected, Actual: T; const Msg: string);
var
  Ok: boolean;
  Msg2, Fmt: string;
begin
Ok := EqualityComparer.Equals( Expected, Actual);
if Ok then exit;
if Msg <> '' then
    Msg2 := Msg
  else
    begin
    Fmt := DefaultEqualsErrorMessageFmt;
    if Fmt = '' then
      Fmt := ExpectedErrorMessage;
    Msg2 := Format( Fmt, [AsDisplayString( Expected), AsDisplayString( Actual), TypeDisplayName])
    end;
if assigned( Harness) then
  Harness.Check( Ok, Msg2)
end;

procedure TGenericCheckable<T>.CheckNotEquals(
  const Harness: ITestHarness; const Expected, Actual: T; const Msg: string);
var
  Ok: boolean;
  Msg2, Fmt: string;
begin
Ok := not EqualityComparer.Equals( Expected, Actual);
if Ok then exit;
if Msg <> '' then
    Msg2 := Msg
  else
    begin
    Fmt := DefaultNotEqualsErrorMessageFmt;
    if Fmt = '' then
      Fmt := ExpectedNotErrorMessage;
    Msg2 := Format( Fmt, [AsDisplayString( Expected), TypeDisplayName])
    end;
if assigned( Harness) then
  Harness.Check( Ok, Msg2)
end;


procedure TGenericCheckable<T>.CheckNotEquals(
  Harness: TTestSuite; const Expected, Actual: T; const Msg: string);
begin
CheckNotEquals( TTestSuiteAccess( Harness).FHarness, Expected, Actual, Msg)
end;

function TGenericCheckable<T>.DefaultEqualsErrorMessageFmt: string;
begin
result := ExpectedErrorMessage
end;


function TGenericCheckable<T>.DefaultNotEqualsErrorMessageFmt: string;
begin
result := ExpectedNotErrorMessage
end;

function TGenericCheckable<T>.EqualityComparer: IEqualityComparer<T>;
begin
result := TEqualityComparer<T>.Default
end;

function TGenericCheckable<T>.Equals( const Left, Right: T): Boolean;
begin
result := True
end;

function TGenericCheckable<T>.GetHashCode(const Value: T): Integer;
begin
result := 0
end;

function TGenericCheckable<T>.Hold( out SelfObj{: TGenericCheckable<T>}): IInterface;
begin
TObject( SelfObj) := self;
result := self
end;

class function TGenericCheckable<T>.TypeDisplayName: string;
begin
result := ''
end;

procedure TGenericCheckable<T>.CheckEquals(
  Harness: TTestSuite; const Expected, Actual: T; const Msg: string);
begin
CheckEquals( TTestSuiteAccess( Harness).FHarness, Expected, Actual, Msg)
end;


{ TCheckableLongword }

class function TCheckableLongword.AsDisplayString(
  const Value: longword): string;
begin
result := Format( '%d', [Value])
end;

class function TCheckableLongword.TypeDisplayName: string;
begin
result := 'longword'
end;

{ TCheckableObject }

class function TCheckableObject.AsDisplayString( const Value: TObject): string;
begin
if assigned( Value) then
    result := Format( '%s @ $%x', [Value.ClassName, NativeUInt(Value)])
  else
    result := 'nil'
end;

class function TCheckableObject.TypeDisplayName: string;
begin
result := 'object'
end;

{ TCheckableClass }

class function TCheckableClass.AsDisplayString(const Value: TClass): string;
begin
if assigned( Value) then
    result := Value.ClassName
  else
    result := 'nil'
end;

class function TCheckableClass.TypeDisplayName: string;
begin
result := 'class reference'
end;

{ TCheckableInterface }

class function TCheckableInterface.AsDisplayString(
  const Value: IInterface): string;
begin
if assigned( Value) then
    result := Format( '$%x', [NativeUInt(Value)])
  else
    result := 'nil'
end;

class function TCheckableInterface.TypeDisplayName: string;
begin
result := 'interface pointer'
end;

{ TCheckableCastInterface }

constructor TCheckableCastInterface.Create( const CastIID: TGUID);
begin
FCastIID := CastIID
end;

function TCheckableCastInterface.EqualityComparer: IEqualityComparer<IInterface>;
begin
result := self
end;

function TCheckableCastInterface.Equals( const Left, Right: IInterface): Boolean;
var
  LeftCast, RightCast: IInterface;
begin
result := (Left = Right) or
   (Supports( Left, FCastIID, LeftCast ) and
    Supports( Left, FCastIID, RightCast) and
    (LeftCast = RightCast))
end;

class function TCheckableCastInterface.TypeDisplayName: string;
begin
result := 'interface pointer'
end;

end.
